home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / COMTABV.S < prev    next >
Encoding:
Text File  |  1993-06-15  |  6.2 KB  |  154 lines
  1. ;;;
  2. ;;;     Copyright (c) 1985 Massachusetts Institute of Technology
  3. ;;;
  4. ;;;     This material was developed by the Scheme project at the
  5. ;;;     Massachusetts Institute of Technology, Department of
  6. ;;;     Electrical Engineering and Computer Science.  Permission to
  7. ;;;     copy this software, to redistribute it, and to use it for any
  8. ;;;     purpose is granted, subject to the following restrictions and
  9. ;;;     understandings.
  10. ;;;
  11. ;;;     1. Any copy made of this software must include this copyright
  12. ;;;     notice in full.
  13. ;;;
  14. ;;;     2. Users of this software agree to make their best efforts (a)
  15. ;;;     to return to the MIT Scheme project any improvements or
  16. ;;;     extensions that they make, so that these may be included in
  17. ;;;     future releases; and (b) to inform MIT of noteworthy uses of
  18. ;;;     this software.
  19. ;;;
  20. ;;;     3.  All materials developed as a consequence of the use of
  21. ;;;     this software shall duly acknowledge such use, in accordance
  22. ;;;     with the usual standards of acknowledging credit in academic
  23. ;;;     research.
  24. ;;;
  25. ;;;     4. MIT has made no warrantee or representation that the
  26. ;;;     operation of this software will be error-free, and MIT is
  27. ;;;     under no obligation to provide any services, by way of
  28. ;;;     maintenance, update, or otherwise.
  29. ;;;
  30. ;;;     5.  In conjunction with products arising from the use of this
  31. ;;;     material, there shall be no use of the name of the
  32. ;;;     Massachusetts Institute of Technology nor of any adaptation
  33. ;;;     thereof in any advertising, promotional, or sales literature
  34. ;;;     without prior written consent from MIT in each case.
  35. ;;;
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ;;;
  38. ;;;     Modified by Texas Instruments Inc 8/15/85
  39. ;;;
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41.  
  42.  
  43. ;;;; Command Tables
  44.  
  45. (define comtab '(()()))
  46. (define default-key #F)
  47.  
  48. (define (%set-comtab-key comtab char command)
  49.   (vector-set! (cdr comtab) (char->integer char) command))
  50.  
  51. (define (%set-comtab-entry! alists char command)
  52.   (let ((entry (assq char (cdr alists))))
  53.     (if entry
  54.         (set-cdr! entry command)
  55.         (set-cdr! alists (cons (cons char command) (cdr alists))))))
  56.  
  57. (define (%comtab-make-prefix-char! alists char alists*)
  58.   (let ((entry (assq char (car alists))))
  59.     (if entry
  60.         (set-cdr! entry alists*)
  61.         (set-car! alists (cons (cons char alists*) (car alists))))))
  62.  
  63. (define (comtab-lookup-prefix char receiver)
  64.   (define (loop char->alist chars)
  65.     (let ((entry (assq (car chars) char->alist)))
  66.       (if entry
  67.           (if (null? (cddr chars))
  68.               (receiver (cdr entry) (cadr chars))
  69.               (loop (cadr entry) (cdr chars)))
  70.           (error "Not a prefix character" (car chars)))))
  71.   (cond ((char? char)
  72.          (receiver comtab char))
  73.         ((pair? char)
  74.          (if (null? (cdr char))
  75.              (receiver comtab (car char))
  76.              (loop (car comtab) char)))
  77.         (else
  78.          (error "Unrecognizable character" char))))
  79.  
  80. (define comtab-entry
  81.   (letrec
  82.       ((ychar '())
  83.        (receiver
  84.          (lambda (alists char)
  85.            (let ((entry (assq char (cdr alists))))
  86.              (cond (entry (cdr entry))
  87.                    (default-key default-key)
  88.                    (else (editor-error (string-append "Unknown command: "
  89.                                             (obj->string ychar)))))))))
  90.     (lambda (xchar)
  91.       (letrec
  92.         ((lookup-vector
  93.            (lambda (*char*)
  94.              (let ((*int* (char->integer *char*)))
  95.                (if (< *int* 256)      ;;; change to 256 for internationalize
  96.                    (vector-ref (cdr comtab) *int*)
  97.                    default-key)))))
  98.         (cond ((char? xchar) (lookup-vector xchar))
  99.               ((and (pair? xchar) (null? (cdr xchar)))
  100.                (lookup-vector (car xchar)))
  101.               (else (set! ychar xchar)
  102.                     (comtab-lookup-prefix xchar receiver)))))))
  103.  
  104.  
  105. (define (set-comtab-entry! char command)
  106.   (comtab-lookup-prefix char
  107.     (lambda (alists char)
  108.       (%set-comtab-entry! alists char command))))
  109.  
  110. ;;; These are not used becuase the initkey stuff is used to define keys
  111.  
  112. ;;;(define (define-key char command-name)
  113. ;;;  (let ((command (name->command command-name)))
  114. ;;;    (cond ((char? char)
  115. ;;;           (%set-comtab-key comtab (char-upcase char) command)
  116. ;;;           (if (char-alphabetic?  char)
  117. ;;;               (%set-comtab-key comtab (char-downcase char) command)))
  118. ;;;          ((and (pair? char) (null? (cdr char)))
  119. ;;;           (%set-comtab-key comtab (char-upcase (car char)) command)
  120. ;;;           (if (char-alphabetic?  char)
  121. ;;;               (%set-comtab-key comtab (char-downcase (car char)) command)))
  122. ;;;          ((pair? char)
  123. ;;;        (comtab-lookup-prefix char
  124. ;;;          (lambda (alists char)
  125. ;;;            (let ((upcase (char-upcase char)))
  126. ;;;              (%set-comtab-entry! alists upcase command)
  127. ;;;              (if (char-alphabetic? char)
  128. ;;;                  (%set-comtab-entry! alists (char-downcase char)
  129. ;;;                                      command))))))
  130. ;;;       ((char-set? char)
  131. ;;;        (mapc (lambda (char) (set-comtab-entry! char command))
  132. ;;;              (char-set-members char)))
  133. ;;;       (else (error "Unknown character" char))))
  134. ;;;  char)
  135. ;;;
  136. ;;;(define (define-prefix-key char command-name)
  137. ;;;  (let ((command (name->command command-name)))
  138. ;;;    (cond ((or (char? char) (pair? char))
  139. ;;;        (comtab-lookup-prefix char
  140. ;;;          (lambda (alists char)
  141. ;;;            (let ((upcase (char-upcase char)))
  142. ;;;              (%set-comtab-key alists upcase command)
  143. ;;;              (%comtab-make-prefix-char! alists upcase (cons '() '()))
  144. ;;;              (if (char-alphabetic? char)
  145. ;;;                  (%comtab-make-synonym-char! alists (char-downcase char)
  146. ;;;                                              alists upcase))))))
  147. ;;;       (else (error "Unknown character" char))))
  148. ;;;  char)
  149. ;;;
  150. ;;;(define (define-default-key command-name)
  151. ;;;  (let ((command (name->command command-name)))
  152. ;;;    (set! default-key command)
  153. ;;;    (set-cdr! comtab (make-vector 128 command))))
  154.